home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / inspect.scm < prev    next >
Text File  |  1995-10-13  |  12KB  |  402 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; A dirty little inspector.
  5. ; This breaks abstractions left and right.
  6. ; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
  7.  
  8. ; Eventually, integrate this better with the command processor.
  9.  
  10. ; Inspector state:
  11. ;    thing  = (focus-object)
  12. ;    menu   = (prepare-menu thing)
  13. ;    start  = position within menu; modified by M (more) command
  14. ;    stack  = list of other things
  15.  
  16. (define *menu-limit* 15)
  17. (define *write-depth* 3)
  18. (define *write-length* 5)
  19.  
  20. (define (with-limited-output thunk)
  21.   (let-fluids $write-depth *write-depth*
  22.               $write-length *write-length*
  23.     thunk))
  24.  
  25. (define (make-inspector-state menu position stack)
  26.   (cons (cons position menu) stack))
  27. (define $inspector-state (make-fluid (make-inspector-state '() 0 '())))
  28.  
  29. (define-command-syntax 'inspect "[<exp>]" "invoke the inspector"
  30.   '(&opt form))
  31.  
  32. (define-command-syntax 'debug "" "inspect the current continuation" '())
  33.  
  34. (define (debug)
  35.   (showing-focus-object
  36.    (lambda ()
  37.      (set-focus-object! (command-continuation))))
  38.   (inspect))
  39.  
  40. (define (inspect . maybe-exp)
  41.   (if (not (null? maybe-exp))
  42.       (with-limited-output
  43.        (lambda ()
  44.      (showing-focus-object
  45.       (lambda ()
  46.         (evaluate-and-select (car maybe-exp)
  47.                  (environment-for-commands)))))))
  48.   (let-fluid $inspector-state
  49.       (make-inspector-state (prepare-menu (focus-object)) 0 '())
  50.     (lambda ()
  51.       (present-menu)
  52.       (let loop ()
  53.     (let ((command (read-command-carefully "inspect: "
  54.                            #f  ;command preferred
  55.                            (command-input)
  56.                            inspector-commands)))
  57.       (cond ((eof-object? command)
  58.          (newline (command-output))
  59.          (unspecific))
  60.         ((not command)   ; read command error
  61.          (loop))
  62.         (else
  63.          (with-limited-output
  64.           (lambda ()
  65.             (execute-inspector-command command)))
  66.          (loop))))))))
  67.  
  68. (define (present-menu)
  69.   (let ((pos+menu (car (fluid $inspector-state))))
  70.     (display-menu (cdr pos+menu)
  71.           (car pos+menu)
  72.           (command-output))))
  73.  
  74. (define (new-selection thing stack)
  75.   (set-fluid! $inspector-state
  76.           (make-inspector-state (prepare-menu thing) 0 stack)))
  77.  
  78. (define (read-selection-command port)
  79.   (let ((x (read port)))
  80.     (if (or (integer? x)
  81.         (memq x '(u d t)))
  82.     x
  83.     (read-command-error port "invalid selection command" x))))
  84.  
  85. (define selection-command-syntax (list '&rest read-selection-command))
  86.  
  87. (define (inspector-commands name)
  88.   (if (integer? name)
  89.       selection-command-syntax
  90.       (case name
  91.     ((? m q) '())               ; no arguments
  92.     ((u d t) selection-command-syntax)
  93.     (else #f))))
  94.  
  95. (define (execute-inspector-command command)
  96.   (let ((result-before (focus-object))
  97.     (state-before (fluid $inspector-state)))
  98.  
  99.     (showing-focus-object
  100.      (lambda ()
  101.  
  102.       (let ((name (car command)))
  103.     (if (integer? name)
  104.         (execute-selection-command command)
  105.         (case name
  106.           ((u d t)
  107.            (execute-selection-command command))
  108.           ((m) (inspect-more))
  109.           ((q) (abort-to-command-level (car (fluid $command-levels))))
  110.           ((?) (inspect-help))
  111.           (else (execute-command command)))))))
  112.  
  113.     (let ((result-after (focus-object))
  114.       (state-after (fluid $inspector-state)))
  115.       ;; Prepare & display a new menu if we're looking at
  116.       ;; a new thing.  Push old thing on stack only if
  117.       ;; no one's been futzing with the stack.
  118.       (if (not (eq? result-after result-before))
  119.       (begin (if (eq? state-after state-before)
  120.              (new-selection result-after
  121.                     (cons result-before
  122.                       (cdr state-before))))
  123.          (present-menu))))))
  124.  
  125. (define (execute-selection-command command)
  126.   (if (not (null? command))
  127.       (let ((name (car command)))
  128.     (if (integer? name)
  129.         (let ((menu (cdar (fluid $inspector-state))))
  130.           (if (and (>= name 0)
  131.                (< name (length menu)))
  132.           (move-to-object! (menu-ref menu name))
  133.           (write-line "Invalid choice." (command-output))))
  134.         (case name
  135.           ((u) (pop-inspector-stack))
  136.           ((d) (inspect-next-continuation))
  137.           ((t) (select-template))
  138.           (else (error "bad selection command" name))))
  139.     (execute-selection-command (cdr command)))))
  140.  
  141. (define (move-to-object! object)
  142.   (new-selection object
  143.          (cons (focus-object)
  144.                (cdr (fluid $inspector-state))))
  145.   (set-focus-object! object))
  146.  
  147. (define (pop-inspector-stack)
  148.   (let ((stack (cdr (fluid $inspector-state))))
  149.     (if (pair? stack)
  150.     (begin (new-selection (car stack) (cdr stack))
  151.            (set-focus-object! (car stack)))
  152.     (write-line "Can't go up from here." (command-output)))))
  153.  
  154. (define (inspect-next-continuation)
  155.   (if (continuation? (focus-object))
  156.       (move-to-object! (continuation-parent (focus-object)))
  157.       (write-line "Can't go down from a non-continuation." (command-output))))
  158.  
  159. (define (inspect-more)
  160.   (let* ((state (fluid $inspector-state))
  161.      (pos+menu (car state))
  162.      (menu (cdr pos+menu))
  163.      (position (car pos+menu)))
  164.     (if (> (length menu) (+ *menu-limit* position))
  165.     (let ((position (- (+ position *menu-limit*) 1)))
  166.       (set-car! pos+menu position)
  167.       (present-menu))
  168.     (write-line "There is no more." (command-output)))))
  169.  
  170. (define (select-template)
  171.   (move-to-object! (coerce-to-template (focus-object))))
  172.  
  173. (define (inspect-help)
  174.   (let ((o-port (command-output)))
  175.     (for-each (lambda (s) (display s o-port) (newline o-port))
  176.           '("q          quit"
  177.         "u          up stack (= go to previous object)"
  178.         "d          down stack"
  179.         "t          template"
  180.         "<form>     evaluate a form (## is current object)"
  181.         "<integer>  menu item"
  182.         "or any command processor command"
  183.         "multiple u d t <integer> commands can be put on one line"))))
  184.               
  185.  
  186. (define (menu-ref menu n)
  187.   (cadr (list-ref menu n)))
  188.  
  189.  
  190. ; Menus.
  191.  
  192. (define (prepare-menu thing)
  193.   (cond ((list? thing)
  194.          (map (lambda (x) (list #f x))
  195.               thing))
  196.  
  197.         ((pair? thing)
  198.          `((car ,(car thing)) (cdr ,(cdr thing))))
  199.  
  200.         ((vector? thing)
  201.          (prepare-menu (vector->list thing)))
  202.  
  203.         ((closure? thing)
  204.          (prepare-environment-menu
  205.               (closure-env thing)
  206.               (get-shape (template-debug-data (closure-template thing))
  207.                          0)))
  208.  
  209.     ((template? thing)
  210.      (prepare-menu (template->list thing)))
  211.  
  212.         ((continuation? thing)
  213.          (prepare-continuation-menu thing))
  214.  
  215.         ((record? thing)
  216.          (prepare-record-menu thing))
  217.  
  218.         ((location? thing)
  219.          `((id ,(location-id thing))
  220.            (contents ,(contents thing))))
  221.  
  222.     ((weak-pointer? thing)
  223.      `((ref ,(weak-pointer-ref thing))))
  224.  
  225.         (else '())))
  226.  
  227. (define (template->list template)
  228.   (do ((i (- (template-length template) 1) (- i 1))
  229.        (r '() (cons (template-ref template i) r)))
  230.       ((< i 0) r)))
  231.  
  232. (define (prepare-continuation-menu thing)
  233.   (let ((dd (continuation-debug-data thing))
  234.         (next (continuation-parent thing)))
  235.     `(,@(let recur ((c thing))
  236.       (if (eq? c next)
  237.           '()
  238.           (let ((z (continuation-arg-count c)))
  239.         (do ((i (- z 1) (- i 1))
  240.              (l (recur (continuation-cont c))
  241.             (cons (list #f (continuation-arg c i))
  242.                   l)))
  243.             ((< i 0) l)))))
  244.       ,@(prepare-environment-menu (continuation-env thing)
  245.                   (get-shape dd (continuation-pc thing))))))
  246.  
  247. (define (continuation-debug-data thing)
  248.   (template-debug-data (continuation-template thing)))
  249.  
  250. (define (prepare-record-menu thing)
  251.   (let ((rt (record-type thing))
  252.         (z (record-length thing)))
  253.     (if (record-type? rt)
  254.         (do ((i (- z 1) (- i 1))
  255.              (f (reverse (record-type-field-names rt)) (cdr f))
  256.              (l '() (cons (list (car f) (record-ref thing i)) l)))
  257.             ((< i 1) l))
  258.         (do ((i (- z 1) (- i 1))
  259.              (l '() (cons (list #f (record-ref thing i)) l)))
  260.             ((< i 0) l)))))
  261.  
  262. (define (prepare-environment-menu env shape)
  263.   (if (vector? env)
  264.       (let ((values (rib-values env)))
  265.         (if (pair? shape)
  266.             (append (map list (car shape) values)
  267.                     (prepare-environment-menu (vector-ref env 0)
  268.                                               (cdr shape)))
  269.             (append (map (lambda (x) (list #f x)) values)
  270.                     (prepare-environment-menu (vector-ref env 0) shape))))
  271.       '()))
  272.  
  273. (define (rib-values env)
  274.   (let ((z (vector-length env)))
  275.     (do ((i 1 (+ i 1))
  276.      (l '() (cons (if (vector-unassigned? env i)
  277.               'unassigned
  278.               (vector-ref env i))
  279.               l)))
  280.     ((>= i z) l))))
  281.  
  282. ; Returns a list of proper lists describing the environment in effect
  283. ; at the given pc with the given template's code vector.
  284. ;
  285. ; Entries in the environment-maps table (one per template) have the form
  286. ;   #(parent-uid pc-in-parent (env-map ...))
  287. ;
  288. ; Each environment map (one per let or lambda-expression) has the form
  289. ;   #(pc-before pc-after (var ...) (env-map ...))
  290. ;
  291. ; Cf. procedure (note-environment vars segment) in comp.scm.
  292.  
  293. (define (get-shape dd pc)
  294.   (if dd
  295.       (let loop ((emaps (debug-data-env-maps dd))
  296.                  (shape (get-shape (get-debug-data
  297.                                     (debug-data-parent dd))
  298.                                    (debug-data-pc-in-parent dd))))
  299.         (if (null? emaps)
  300.             shape
  301.             (let ((pc-before (vector-ref (car emaps) 0))
  302.                   (pc-after  (vector-ref (car emaps) 1))
  303.                   (vars      (vector-ref (car emaps) 2))
  304.                   (more-maps (vector-ref (car emaps) 3)))
  305.               (if (and (>= pc pc-before)
  306.                        (< pc pc-after))
  307.                   (loop more-maps
  308.                         (cons (vector->list vars) shape))
  309.                   (loop (cdr emaps) shape)))))
  310.       '()))
  311.  
  312.  
  313.  
  314. ; Information display
  315.  
  316. (define (display-menu menu start port)
  317.   (newline port)
  318.   (let ((thing (focus-object)))
  319.     (if (continuation? thing)
  320.     (let ((dd (continuation-debug-data thing)))
  321.       (if dd
  322.           (let ((source (assoc (continuation-pc thing)
  323.                    (debug-data-source dd))))
  324.         (if source
  325.             (display-source-info (cdr source))))))))
  326.   (let ((menu (list-tail menu start))
  327.     (limit (+ start *menu-limit*)))
  328.     (let loop ((i start) (menu menu))
  329.       (with-limited-output
  330.        (lambda ()
  331.      (cond ((null? menu))
  332.            ((and (>= i limit)
  333.              (not (null? (cdr menu))))
  334.         (display " [m] more..." port) (newline port))
  335.            (else
  336.         (let ((item (car menu)))
  337.           (display " [" port)
  338.           (write i port)
  339.           (if (car item)
  340.               (begin (display ": " port)
  341.                  (write-carefully (car item) port)))
  342.           (display "] " port)
  343.           (write-carefully
  344.            (value->expression (cadr item))
  345.            port)
  346.           (newline port)
  347.           (loop (+ i 1) (cdr menu))))))))))
  348.  
  349. (define (display-source-info info)
  350.   (if (pair? info)
  351.       (let ((o-port (command-output))
  352.         (i (car info))
  353.         (exp (cdr info)))
  354.     (if (and (integer? i) (list? exp))
  355.         (begin
  356.         (display "Waiting for " o-port)
  357.         (limited-write (list-ref exp i) o-port
  358.                    *write-depth* *write-length*)
  359.         (newline o-port)
  360.         (display "  in " o-port)
  361.         (limited-write (append (sublist exp 0 i)
  362.                        (list '^^^)
  363.                        (list-tail exp (+ i 1)))
  364.                    o-port
  365.                    *write-depth* *write-length*)
  366.         (newline o-port))))))
  367.  
  368.  
  369.  
  370.  
  371. (define (where-defined thing)
  372.   (let loop ((dd (template-debug-data (closure-template thing))))
  373.     (if (debug-data? dd)
  374.     (if (string? (debug-data-name dd))
  375.         (debug-data-name dd)
  376.         (loop (debug-data-parent dd)))
  377.     #f)))
  378.  
  379. (define-command-syntax 'where "[<procedure>]"
  380.   "show procedure's source file name"
  381.   '(&opt expression))
  382.  
  383. (define (where . maybe-exp)
  384.   (let ((proc (if (null? maybe-exp)
  385.           (focus-object)
  386.           (evaluate (car maybe-exp) (environment-for-commands))))
  387.     (port (command-output)))
  388.     (if (procedure? proc)
  389.     (let ((probe (where-defined proc)))
  390.       (if probe
  391.           (display probe port)
  392.           (display "Source file not recorded" port)))
  393.     (display "Not a procedure" port))
  394.     (newline port)))
  395.  
  396.  
  397. (define (coerce-to-template obj)    ;utility for various commands
  398.   (cond ((template? obj) obj)
  399.     ((closure? obj) (closure-template obj))
  400.     ((continuation? obj) (continuation-template obj))
  401.     (else (error "expected a procedure or continuation" obj))))
  402.